Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Peter Lewis/Morpion 1.0.0/source/Game.p

Text File | 1993-12-03 | 11.1 KB | 519 lines | [TEXT/PJMM]

unit Game;

interface

    procedure InitGame;
    procedure FinishGame;

implementation

    uses
        MyOOMainLoop, MyDialogs, MyFMenus, MyUtils, MyMathUtils, MySpeak;

    const
        max_row = 20;
        max_col = 20;
        cross = 4;
        len = 5;

    type
        rows = 1..max_row;
        cols = 1..max_col;

    var
        dr, dc: array[0..7] of integer;

    type
        GameObject = object(DObject)
                finished, auto, show: boolean;
                vertex: array[rows, cols] of boolean;
                edges: array[rows, cols] of byte;
                score, moves: integer;
                mover, movec, moved: integer;
                diff: integer;
                procedure Create (id: integer);
                override;
                procedure Resize;
                override;
                procedure DrawBoard;
                function InRange (r, c: integer): boolean;
                function PointToCell (pt: Point; var r, c: integer): boolean;
                procedure CellToPoint (r, c: integer; var pt: Point);
                procedure DrawVertex (r, c: integer);
                function ValidLine (r, c, d: integer): boolean;
                procedure ShowMoves;
                procedure DLine (start: Point; dir: integer);
                procedure DoLine (r, c, d: integer);
                procedure DoMove (pt: Point);
                procedure DoItemWhere (er: eventRecord; item: integer);
                override;
            end;

    procedure GameObject.Resize;
        var
            r: rect;
    begin
        r.left := 0;
        r.right := window^.portrect.right - 16;
        r.top := 0;
        r.bottom := window^.portrect.bottom - 16;
        SetDItemRect(window, 1, r);
        diff := (Min(r.bottom, r.right) - 4) div (Max(max_row, max_col));
        SetPort(window);
        InsetRect(r, -100, -100);
        InvalRect(r);
    end;

    function GameObject.InRange (r, c: integer): boolean;
    begin
        InRange := (0 < r) & (r <= max_row) & (0 < c) & (c <= max_col);
    end;

    function GameObject.PointToCell (pt: Point; var r, c: integer): boolean;
    begin
        r := (pt.v + diff div 2) div diff;
        c := (pt.h + diff div 2) div diff;
        PointToCell := InRange(r, c);
    end;

    procedure GameObject.CellToPoint (r, c: integer; var pt: Point);
    begin
        pt.h := c * diff;
        pt.v := r * diff;
    end;

    procedure GameObject.Create (id: integer);
        var
            r, c, i, size: integer;
    begin
        inherited Create(id);
        draw_grow_icon := true;
        finished := false;
        score := 0;
        for r := 1 to max_row do begin
            for c := 1 to max_col do begin
                vertex[r, c] := false;
                edges[r, c] := 0;
            end;
        end;
        size := 3 * cross - 2;
        r := (max_row - size) div 2 + 1;
        c := (max_row - size) div 2 + 1;
        for i := 0 to cross - 1 do begin
            vertex[r, c + cross - 1 + i] := true;
            vertex[r + size - 1, c + cross - 1 + i] := true;
            vertex[r + cross - 1 + i, c] := true;
            vertex[r + cross - 1 + i, c + size - 1] := true;
            vertex[r + cross - 1, c + i] := true;
            vertex[r + 2 * cross - 2, c + i] := true;
            vertex[r + cross - 1, c + size - 1 - i] := true;
            vertex[r + 2 * cross - 2, c + size - 1 - i] := true;
            vertex[r + i, c + cross - 1] := true;
            vertex[r + i, c + 2 * cross - 2] := true;
            vertex[r + size - 1 - i, c + cross - 1] := true;
            vertex[r + size - 1 - i, c + 2 * cross - 2] := true;
        end;
        Resize;
        DrawBoard;
    end;

    procedure GameObject.DrawVertex (r, c: integer);
        const
            d = 2;
        var
            i: integer;
            mid: Point;
    begin
        CellToPoint(r, c, mid);
        MoveTo(mid.h, mid.v);
        if not vertex[r, c] then begin
            Line(0, 0);
        end
        else begin
            Move(-d, -d);
            Line(d * 2, d * 2);
            Move(-2 * d, 0);
            Line(d * 2, -d * 2);
            Move(0, d);
            Line(-2 * d, 0);
            Move(d, -d);
            Line(0, 2 * d);
        end;
        for i := 0 to 7 do begin
            if BTST(edges[r, c], i) then begin
                MoveTo(mid.h, mid.v);
                Line(diff * dc[i], diff * dr[i]);
            end;
        end;
    end;

    procedure GameObject.DrawBoard;
        var
            r, c, d, count: integer;
            box: rect;
            mid: Point;
    begin
        SetPort(window);
        GetDItemRect(window, 1, box);
        EraseRect(box);
        DrawGrowIcon(window);
        for r := 1 to max_row do begin
            for c := 1 to max_col do begin
                DrawVertex(r, c);
            end;
        end;
        ShowMoves;
    end;

    function GameObject.ValidLine (r, c, d: integer): boolean;
        var
            good: boolean;
            i, cnt: integer;
    begin
        good := InRange(r, c);
        cnt := 0;
        i := 0;
        while good and (i <= len - 2) do begin
            cnt := cnt + ord(vertex[r, c]);
            if BTST(edges[r, c], d) then begin
                good := false;
            end;
            r := r + dr[d];
            c := c + dc[d];
            good := good & InRange(r, c);
            i := i + 1;
        end;
        if good then begin
            cnt := cnt + ord(vertex[r, c]);
        end;
        ValidLine := good and (cnt >= 4);
    end;

    procedure GameObject.DoLine (r, c, d: integer);
        procedure DoSet (var b: byte; bit: integer);
            var
                n: longInt;
        begin
            n := b;
            BSET(n, bit);
            b := n;
        end;
        var
            i: integer;
    begin
        if ValidLine(r, c, d) then begin
            for i := 0 to len - 2 do begin
                vertex[r, c] := true;
                DoSet(edges[r, c], d);
                DoSet(edges[r + dr[d], c + dc[d]], BAND(d + 4, 7));
                DrawVertex(r, c);
                r := r + dr[d];
                c := c + dc[d];
            end;
            vertex[r, c] := true;
            DrawVertex(r, c);
            score := score + 1;
            if show then begin { redraw the whole board }
                DrawBoard;
            end
            else begin { calculate the moves }
                ShowMoves;
            end;
        end;
    end;

    procedure GameObject.DLine (start: Point; dir: integer);
    begin
        if dir <> -1 then begin
            MoveTo(start.h, start.v);
            Line(diff * (len - 1) * dc[dir], diff * (len - 1) * dr[dir]);
        end;
    end;

    procedure GameObject.ShowMoves;
        var
            start, org: Point;
            r, c, i, cnt: integer;
            ps: penState;
            title: str255;

        function RandomChance (n: integer): boolean;
        begin
            if n <= 1 then begin
                RandomChance := true;
            end
            else begin
                RandomChance := (Band(Random, $7FFF) mod n) = 0;
            end;
        end;
        procedure TestDirection (i: integer);
        begin
            if (vertex[r, c] | vertex[r + dr[i], c + dc[i]]) & ValidLine(r, c, i) then begin
                if show then begin
                    DLine(start, i);
                end;
                cnt := cnt + 1;
                if RandomChance(cnt) then begin
                    mover := r;
                    movec := c;
                    moved := i;
                end;
            end;
        end;

    begin
        SetPort(window);
        GetPenState(ps);
        PenPat(ltgray);
        cnt := 0;
        for r := 1 to max_row do begin
            for c := 1 to max_col do begin
                CellToPoint(r, c, start);
                if (r >= len) & (c <= max_col - len + 1) then begin
                    TestDirection(1);
                end;
                if (c <= max_col - len + 1) then begin
                    TestDirection(2);
                end;
                if (r <= max_row - len + 1) & (c <= max_col - len + 1) then begin
                    TestDirection(3);
                end;
                if (r <= max_row - len + 1) then begin
                    TestDirection(4);
                end;

            end;
        end;
        SetPenState(ps);
        moves := cnt;
        finished := moves = 0;
        if show or true then begin
            title := StringOf('Score: ', score : 1, ' Moves: ', moves : 1);
        end
        else begin
            title := StringOf('Score: ', score : 1);
        end;
        if finished then begin
            title := concat('(', title, ')');
        end;
        SetWindowTitle(window, title);
    end;

    procedure GameObject.DoMove (pt: Point);
        var
            start: Point;
            goods: array[0..7] of boolean;
            fin: Point;
            r, c, d, i, cnt, mini, oldmini: integer;
            dist, mindist: longInt;
            ps: penState;
    begin
        if PointToCell(pt, r, c) then begin
            cnt := 0;
            for i := 0 to 7 do begin
                goods[i] := ValidLine(r, c, i);
                cnt := cnt + ord(goods[i]);
            end;
            CellToPoint(r, c, start);
            GetPenState(ps);
            PenMode(patXor);
            PenPat(dkgray);
            oldmini := -1;
            while Button do begin
                GetMouse(pt);
                mini := -1;
                mindist := maxInt;
                fin.h := start.h - pt.h;
                fin.v := start.v - pt.v;
                dist := longint(fin.h) * fin.h + longInt(fin.v) * fin.v;
                if dist < longInt(len) * len * diff * diff * 3 div 2 then begin
                    for i := 0 to 7 do begin
                        if goods[i] then begin
                            fin.h := pt.h - (start.h + dc[i] * diff * len * (3 - ord(odd(i))) div 3);
                            fin.v := pt.v - (start.v + dr[i] * diff * len * (3 - ord(odd(i))) div 3);
                            dist := longInt(fin.h) * fin.h + longInt(fin.v) * fin.v;
                            if dist < mindist then begin
                                mindist := dist;
                                mini := i;
                            end;
                        end;
                    end;
                end;
                if (oldmini <> mini) then begin
                    DLine(start, oldmini);
                    DLine(start, mini);
                    oldmini := mini;
                end;
            end;
            DLine(start, oldmini);
            SetPenState(ps);
            if oldmini <> -1 then begin
                d := oldmini;
                repeat
                    DoLine(r, c, d);
                    r := mover;
                    c := movec;
                    d := moved;
                until not auto or (moves <> 1);
            end;
        end;
    end;

    procedure gameObject.DoItemWhere (er: eventRecord; item: integer);
    begin
        case item of
            1:  begin
                SetPort(window);
                GlobalToLocal(er.where);
                if moves > 0 then begin
                    DoMove(er.where);
                    if moves = 0 then begin
                        if SpeechAvailable then begin
                            Speak(128, 6);
                        end;
                    end;
                end;
            end;
            otherwise
                ;
        end;
    end;

    procedure DrawProc (dlg: DialogPtr; item: integer);
    begin
        GameObject(GetWObject(dlg)).DrawBoard;
    end;

    procedure NewGame;
        var
            obj: GameObject;
    begin
        new(obj);
        obj.Create(200);
        obj.show := false;
        obj.auto := true;
        SetDItemHandle(obj.window, 1, @DrawProc);
        ShowWindow(obj.window);
    end;

    procedure SetNewGameMenu (themenu, theitem: integer);
        var
            t, c: longInt;
    begin
        PurgeSpace(t, c);
        SetIDItemEnable(themenu, theitem, c > 25000);
    end;

    function GetGameObject: GameObject;
        var
            can: boolean;
            obj: WObject;
    begin
        obj := nil;
        if FrontWindow <> nil then begin
            obj := GetWObject(FrontWindow);
            if not member(obj, GameObject) | GameObject(obj).finished then begin
                obj := nil;
            end;
        end;
        GetGameObject := GameObject(obj);
    end;

    procedure ToggleAutoMove;
        var
            obj: GameObject;
    begin
        obj := GameObject(GetWObject(FrontWindow));
        obj.auto := not obj.auto;
    end;

    procedure SetToggleAutoMoveMenu (themenu, theitem: integer);
        var
            obj: GameObject;
    begin
        obj := GetGameObject;
        SetIDItemEnable(themenu, theitem, obj <> nil);
        SetItemMark(GetMHandle(themenu), theitem, chr($12 * ord((obj <> nil) & obj.auto)));
    end;

    procedure ToggleShowMoves;
        var
            obj: GameObject;
            r: rect;
    begin
        obj := GetGameObject;
        obj.show := not obj.show;
        if obj.show then begin
            obj.ShowMoves;
        end
        else begin
            obj.DrawBoard;
        end;
    end;

    procedure SetToggleShowMovesMenu (themenu, theitem: integer);
        var
            obj: GameObject;
    begin
        obj := GetGameObject;
        SetIDItemEnable(themenu, theitem, obj <> nil);
        SetItemMark(GetMHandle(themenu), theitem, chr($12 * ord((obj <> nil) & obj.show)));
    end;

    procedure DoBestMove;
        var
            obj: GameObject;
    begin
        obj := GetGameObject;
        obj.DoLine(obj.mover, obj.movec, obj.moved);
    end;

    procedure DoLotsOfMoves;
        var
            obj: GameObject;
            er: EventRecord;
            dummy: boolean;
    begin
        obj := GetGameObject;
        while (obj.moves > 0) & not Button do begin
            obj.DoLine(obj.mover, obj.movec, obj.moved);
        end;
    end;

    procedure SetDoBestMenu (themenu, theitem: integer);
    begin
        SetIDItemEnable(themenu, theitem, GetGameObject <> nil);
    end;

{$S Init}
    procedure InitGame;
    begin
        SetFBoth('game', @NewGame, @SetNewGameMenu);
        SetFBoth('auto', @ToggleAutoMove, @SetToggleAutoMoveMenu);
        SetFBoth('show', @ToggleShowMoves, @SetToggleShowMovesMenu);
        SetFBoth('best', @DoBestMove, @SetDoBestMenu);
        SetFBoth('lots', @DoLotsOfMoves, @SetDoBestMenu);
        dr[0] := -1;
        dr[1] := -1;
        dr[2] := 0;
        dr[3] := 1;
        dr[4] := 1;
        dr[5] := 1;
        dr[6] := 0;
        dr[7] := -1;
        dc[0] := 0;
        dc[1] := 1;
        dc[2] := 1;
        dc[3] := 1;
        dc[4] := 0;
        dc[5] := -1;
        dc[6] := -1;
        dc[7] := -1;
    end;

{$S Term}
    procedure FinishGame;
    begin
    end;

end.